home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Mac Mania 4
/
MacMania 4.toast
/
/
Games&Education
/
ez-genes-02
/
Source 0.2
/
UFamily.p
< prev
next >
Wrap
Text File
|
1995-04-27
|
33KB
|
1,502 lines
unit UFamily;
interface
uses
UGridView, UTEView, UDialog, UMacApp, UFile;
const
kNameSize = 31; { Maximum size string supported for a name }
kSignature = 'famT'; { Application signature }
kFileType = 'text'; { File-type code used for document files }
kWindowID = 1025; { The resource ID of the the view Resource }
kClusterID = 1034;
kPersonWindow = 1035;
kCoupleWindow = 1036;
kHandCursor = 1704;
kDontExist = '(*)';
kNotImplemented = 'Notes not yet implemented';
cAncestor = 1201;
cDescendant = 1202;
cAddParents = 1211;
cAddSpouse = 1212;
cAddChild = 1213;
cEditPerson = 1218;
cDelePerson = 1219;
cDispFather = 1220;
cDispMother = 1221;
cDispSpouse = 1222;
cDispChild = 1223;
cGoto = 1229;
type
NameStr = string[kNameSize];
TPerson = object(TSortedList)
fFirst, fLast: NameStr;
fBirth, fDeath: longint;
fPlace: NameStr;
fMale: boolean;
parents: TCouple;
{spouses: TCoupleList; Dynamic fields appended at the end of object--see TList}
procedure TPerson.Init;
function TPerson.FullName: str255;
function TPerson.FullBirth: str255;
procedure TPerson.AddParents (C: TCouple);
procedure TPerson.AddSpouse (C: TCouple);
procedure TPerson.AddChild (P: TPerson);
function TPerson.Father: TPerson;
function TPerson.Mother: TPerson;
function TPerson.Spouse (k: integer): TPerson;
function TPerson.NumberOfDescendants: integer;
procedure TPerson.WriteDescendants (F: TTextFile; n: integer);
procedure TPerson.MakeDescendants (n: integer);
procedure TPerson.MakeAncestors (n: integer);
function TPerson.Compare (item1, item2: TObject): CompareResult;
OVERRIDE;
procedure TPerson.GetInspectorName (var inspectorName: Str255);
OVERRIDE;
procedure TPerson.DynamicFields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
OVERRIDE;
procedure TPerson.Fields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
OVERRIDE;
end;
TPersonList = object(TSortedList)
procedure TPersonList.Init;
function TPersonList.Compare (item1, item2: TObject): CompareResult;
OVERRIDE;
end;
TCouple = object(TSortedList)
husband, wife: TPerson;
fDate: longint;
{children: TPersonList; Dynamic fields}
procedure TCouple.Init;
function TCouple.Compare (item1, item2: TObject): CompareResult;
OVERRIDE;
procedure TCouple.GetInspectorName (var inspectorName: Str255);
OVERRIDE;
procedure TCouple.DynamicFields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
OVERRIDE;
procedure TCouple.Fields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
OVERRIDE;
end;
TCoupleList = TList;
TFamilyDoc = object(TDocument)
fMen, fWomen: TPersonList;
fCouples: TCoupleList;
fCurrent: TPerson;
fFamily: TList;
iFather, iMother: TActiveText;
iName, iBirth: TStaticText;
iNote: TEditText;
iFamily: TFamilyView;
procedure TFamilyDoc.Init;
procedure TFamilyDoc.Free;
OVERRIDE;
function TFamilyDoc.NewPerson (isMale: boolean): TPerson;
function TFamilyDoc.NewCouple (Husband, Wife: TPerson): TCouple;
function TFamilyDoc.EditPerson (P: TPerson; title: str255): boolean;
function TFamilyDoc.EditCouple (C: TCouple; L1, L2: str255): boolean;
procedure TFamilyDoc.AddPerson (P: TPerson);
procedure TFamilyDoc.RemovePerson (P: TPerson);
procedure TFamilyDoc.DeletePerson (P: TPerson);
procedure TFamilyDoc.AddParents;
procedure TFamilyDoc.AddSpouse;
procedure TFamilyDoc.AddChild;
procedure TFamilyDoc.SetPerson (P: TPerson);
procedure TFamilyDoc.SetFamilyView;
procedure TFamilyDoc.DoMakeViews (forPrinting: BOOLEAN);
OVERRIDE;
procedure TFamilyDoc.DoChoice (origView: TView; itsChoice: INTEGER);
OVERRIDE;
procedure TFamilyDoc.DoSetupMenus;
OVERRIDE;
function TFamilyDoc.DoMenuCommand (aCmdNumber: CmdNumber): TCommand;
OVERRIDE;
function TFamilyDoc.DoKeyCommand (ch: Char; aKeyCode: INTEGER; var info: EventInfo): TCommand;
OVERRIDE;
procedure TFamilyDoc.DoInitialState;
OVERRIDE;
procedure TFamilyDoc.DoRead (aRefNum: INTEGER; rsrcExists, forPrinting: BOOLEAN);
OVERRIDE;
procedure TFamilyDoc.DoWrite (aRefNum: INTEGER; makingCopy: BOOLEAN);
OVERRIDE;
procedure TFamilyDoc.DoNeedDiskSpace (var dataForkBytes, rsrcForkBytes: LONGINT);
OVERRIDE;
procedure TFamilyDoc.Fields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
OVERRIDE;
end;
TFamilyView = object(TTextListView)
fSpouses: set of 0..31;
procedure TFamilyView.GetItemText (anItem: INTEGER; var aString: Str255);
OVERRIDE;
procedure TFamilyView.SelectItem (anItem: INTEGER; extendSelection, highlight, select: BOOLEAN);
OVERRIDE;
procedure TFamilyView.SetNumberOfItems (aNumber: INTEGER);
procedure TFamilyView.DrawCell (aCell: GridCell; aQDRect: Rect);
OVERRIDE;
function TFamilyView.DoSetCursor (localPoint: Point; cursorRgn: RgnHandle): BOOLEAN;
OVERRIDE;
end;
TActiveText = object(TStaticText)
fPerson: TPerson;
procedure TActiveText.SetPerson (P: TPerson);
function TActiveText.DoSetCursor (localPoint: Point; cursorRgn: RgnHandle): BOOLEAN;
OVERRIDE;
procedure TActiveText.DoChoice (origView: TView; itsChoice: INTEGER);
OVERRIDE;
end;
TPersonCluster = object(TCluster)
iMale: TCheckBox;
iFrst: TEditText;
iLast: TEditText;
iPlac: TEditText;
iBirt: TNumberText;
iDeat: TNumberText;
iNote: TEditText;
procedure TPersonCluster.Init;
procedure TPersonCluster.GetDataFrom (P: TPerson);
procedure TPersonCluster.PutDataInto (P: TPerson);
end;
var
gPersonData, gHusbandData, gWifeData: TPersonCluster;
gBlue, gRed: RGBColor;
procedure InitDialogs;
implementation
uses
UDebug;
procedure InitDialogs;
var
W: TWindow;
D: TDialogView;
offset: longint;
begin
W := NewTemplateWindow(kPersonWindow, nil);
FailNIL(W);
D := TDialogView(W.FindSubView('dlog'));
FailNIL(D);
gPersonData := TPersonCluster(gApplication.DoCreateViews(nil, D, kClusterID, gZeroVPt));
FailNIL(gPersonData);
gPersonData.Init;
offset := W.fSize.v - 16;
W := NewTemplateWindow(kCoupleWindow, nil);
FailNIL(W);
D := TDialogView(W.FindSubView('dlog'));
FailNIL(D);
gHusbandData := TPersonCluster(gApplication.DoCreateViews(nil, D, kClusterID, gZeroVPt));
FailNIL(gHusbandData);
gHusbandData.Init;
gHusbandData.fIdentifier := 'husb';
gHusbandData.iMale.DimState(true, false);
D.MakeFirstSubview(gHusbandData);
gWifeData := TPersonCluster(gApplication.DoCreateViews(nil, D, kClusterID, gZeroVPt));
FailNIL(gWifeData);
gWifeData.Init;
gWifeData.fIdentifier := 'wife';
gWifeData.iMale.DimState(true, false);
with gWifeData.fLocation do
v := v + offset;
SetRGBColor(gBlue, 0, 0, $D400);
SetRGBColor(gRed, $DD6B, $8C2, $6A2);
end;
function OpenNewFile (prompt, fName: Str255; Owner, Kind: OSType): INTEGER;
var
FS: FSSpec;
Reply: StandardFileReply;
err, fFile: integer;
begin
OpenNewFile := kNoFileRefnum;
gApplication.UpdateAllWindows;
StandardPutFile(prompt, fName, reply);
if Reply.sfGood then
begin
FS := Reply.sfFile;
err := FSpOpenDF(FS, fsCurPerm, fFile);
if err <> fnfErr then
FailOSErr(err)
else
begin
FailOSErr(FSpCreate(FS, Owner, Kind, Reply.sfScript));
FailOSErr(FSpOpenDF(FS, fsCurPerm, fFile));
end;
OpenNewFile := fFile;
end;
end;
{==========================================================================}
{ TPerson }
{==========================================================================}
procedure TPerson.Init;
begin
ISortedList;
fFirst := '';
fLast := '';
fBirth := 0;
fDeath := 0;
fPlace := '';
fMale := true;
parents := nil;
{$IFC qDebug}
SetEltType('TCouple');
{$ENDC}
end;
function TPerson.FullName: str255;
begin
FullName := concat(fFirst, ' ', fLast);
end;
function TPerson.FullBirth: str255;
var
B, D: str255;
begin
if fBirth = 0 then
FullBirth := ''
else
begin
NumToString(fBirth, B);
if fDeath = 0 then
FullBirth := B
else
begin
NumToString(fDeath, D);
FullBirth := concat(B, '-', D);
end;
end;
end;
procedure TPerson.AddParents (C: TCouple);
begin
SELF.parents := C;
C.Insert(SELF);
end;
procedure TPerson.AddSpouse (C: TCouple);
begin
SELF.Insert(C);
if fMale then
C.wife.Insert(C)
else
C.husband.Insert(C);
end;
procedure TPerson.AddChild (P: TPerson);
var
C: TCouple;
begin
C := TCouple(SELF.Last); {last marriage}
P.parents := C;
C.Insert(P);
end;
function TPerson.Father: TPerson;
begin
if parents = nil then
Father := nil
else
Father := parents.husband;
end;
function TPerson.Mother: TPerson;
begin
if parents = nil then
Mother := nil
else
Mother := parents.wife;
end;
function TPerson.Spouse (k: integer): TPerson;
var
C: TCouple;
begin
if (fSize < k) then
Spouse := nil
else
begin
C := TCouple(At(k));
if fMale then
Spouse := C.wife
else
Spouse := C.husband;
end;
end;
function TPerson.NumberOfDescendants: integer;
var
n: integer;
procedure DoToChild (P: TPerson);
begin
n := n + P.NumberOfDescendants;
end;
procedure DoToSpouse (C: TCouple);
begin
C.Each(DoToChild);
end;
begin
if fSize = 0 then
NumberOfDescendants := 1 {Always count yourself!}
else
begin
n := 0;
Each(DoToSpouse);
NumberOfDescendants := n + 1;
end;
end;
function TABs (n: integer): str255;
var
k: integer;
S: str255;
begin
S[0] := chr(n);
for k := 1 to n do
S[k] := chTAB;
TABs := S;
end;
procedure TPerson.WriteDescendants (F: TTextFile; n: integer);
var
S: str255;
procedure DoToChild (P: TPerson);
begin
if (P.fSize = 0) | (n = 0) then
begin
{$IFC qDebug}
writeln(' ' : 4 * (5 - n), P.fFirst);
{$ENDC}
S := concat(TABs(5 - n), P.fFirst);
F.WriteLine(S);
end
else
P.WriteDescendants(F, n - 1);
end;
procedure DoToSpouse (C: TCouple);
begin
NumToString(C.fDate, S);
{$IFC qDebug}
if fMale then
writeln(' ' : 4 * (4 - n), C.husband.fFirst, ' <', S, '> ', C.wife.fFirst)
else
writeln(' ' : 4 * (4 - n), C.wife.fFirst, ' <', S, '> ', C.husband.fFirst);
{$ENDC}
if fMale then
S := concat(TABs(4 - n), C.husband.FullName, ' <', S, '> ', C.wife.FullName)
else
S := concat(TABs(4 - n), C.wife.FullName, ' <', S, '> ', C.husband.FullName);
F.WriteLine(S);
C.Each(DoToChild);
end;
begin
Each(DoToSpouse);
end;
procedure TPerson.MakeDescendants (n: integer);
var
F: TTextFile;
RefNum, err: integer;
S: str255;
begin
S := concat(SELF.FullName, ' >>');
{$IFC qDebug}
writeln(S);
{$ENDC}
RefNum := OpenNewFile('Descendants', S, 'ttxt', 'TEXT');
new(F);
FailNil(F);
F.ITextFile(RefNum, kDisk);
WriteDescendants(F, n);
F.Free;
err := FSClose(RefNum);
end;
procedure TPerson.MakeAncestors (n: integer);
var
F: TTextFile;
RefNum, err: integer;
S: str255;
procedure DoToParents (P: TPerson; n: integer);
begin
if (n > 0) and (P.Father <> nil) then
DoToParents(P.Father, n - 1);
{$IFC qDebug}
writeln(' ' : 8 * n, P.fFirst);
{$ENDC}
S := concat(TABs(n), P.FullName);
F.WriteLine(S);
S := concat(TABs(n), P.FullBirth, ' ', P.fPlace);
F.WriteLine(S);
if (n > 0) and (P.Mother <> nil) then
DoToParents(P.Mother, n - 1);
end;
begin
S := concat('>> ', SELF.FullName);
{$IFC qDebug}
writeln(S);
{$ENDC}
RefNum := OpenNewFile('Ancestors', S, 'ttxt', 'TEXT');
new(F);
FailNil(F);
F.ITextFile(RefNum, kDisk);
DoToParents(SELF, n);
F.Free;
err := FSClose(RefNum);
end;
function TPerson.Compare (item1, item2: TObject): CompareResult;
OVERRIDE;
begin
Compare := (TCouple(item1).fDate - TCouple(item2).fDate);
end;
procedure TPersonList.Init;
begin
ISortedList;
{$IFC qDebug}
SetEltType('TPerson');
{$ENDC}
end;
function TPersonList.Compare (item1, item2: TObject): CompareResult;
OVERRIDE;
begin
Compare := IUCompString(TPerson(item1).fFirst, TPerson(item2).fFirst)
end;
{==========================================================================}
{ TCouple }
{==========================================================================}
procedure TCouple.Init;
begin
ISortedList;
husband := nil;
wife := nil;
fDate := 0;
{$IFC qDebug}
SetEltType('TPerson');
{$ENDC}
end;
function TCouple.Compare (item1, item2: TObject): CompareResult;
OVERRIDE;
begin
Compare := (TPerson(item1).fBirth - TPerson(item2).fBirth);
end;
{==========================================================================}
{ TFamilyDoc }
{==========================================================================}
procedure TFamilyDoc.Init;
begin
IDocument(kFileType, kSignature, kUsesDataFork, not kUsesRsrcFork, not kDataOpen, not kRsrcOpen);
fSavePrintInfo := false;
new(fMen);
FailNil(fMen);
fmen.init;
new(fWomen);
FailNil(fWomen);
fWomen.init;
fCouples := TCoupleList(newList);
{$IFC qDebug}
fCouples.SetEltType('TCouple');
{$ENDC}
fCurrent := nil;
fFamily := newList;
{$IFC qDebug}
fFamily.SetEltType('TPerson');
{$ENDC}
iFather := nil;
iMother := nil;
iName := nil;
iBirth := nil;
iNote := nil;
iFamily := nil;
end;
procedure TFamilyDoc.Free;
OVERRIDE;
begin
fMen.FreeList; {Free all the elements, as well as the list}
fWomen.FreeList;
fCouples.FreeList;
fFamily.Free;
inherited Free;
end;
function TFamilyDoc.NewPerson (isMale: boolean): TPerson;
var
P: TPerson;
begin
New(P);
FailNil(P);
P.Init;
P.fMale := isMale;
NewPerson := P;
end;
function TFamilyDoc.NewCouple (Husband, Wife: TPerson): TCouple;
var
C: TCouple;
begin
New(C);
FailNil(C);
C.Init;
C.husband := Husband;
C.wife := Wife;
NewCouple := C;
end;
function TFamilyDoc.EditPerson (P: TPerson; title: str255): boolean;
var
D: TDialogView;
dismisser: IDType;
wasMale: boolean;
begin
D := TDialogView(gPersonData.GetDialogView);
wasMale := P.fMale;
gPersonData.SetLabel(title, false);
gPersonData.GetDataFrom(P);
gPersonData.iMale.DimState(P.fSize > 0, false); {cannot modify sex of a married person}
D.DoSelectEditText(gPersonData.iFrst, kSelect);
dismisser := D.PoseModally;
D.GetWindow.Close;
if dismisser = 'cncl' then
begin
EditPerson := false;
exit(EditPerson);
end;
EditPerson := true;
SetChangeCount(fChangeCount + 1);
gPersonData.PutDataInto(P);
if wasMale <> P.fMale then
AddPerson(P);
end;
function TFamilyDoc.EditCouple (C: TCouple; L1, L2: str255): boolean;
var
D: TDialogView;
dismisser: IDType;
iDate: TNumberText;
begin
D := TDialogView(gHusbandData.GetDialogView);
iDate := TNumberText(D.FindSubView('date'));
FailNIL(iDate);
iDate.SetValue(C.fDate, false);
gHusbandData.SetLabel(L1, false);
gHusbandData.GetDataFrom(C.husband);
gWifeData.SetLabel(L2, false);
gWifeData.GetDataFrom(C.wife);
D.DoSelectEditText(iDate, kSelect);
dismisser := D.PoseModally;
D.GetWindow.Close;
if dismisser = 'cncl' then
begin
EditCouple := false;
exit(EditCouple);
end;
EditCouple := true;
SetChangeCount(fChangeCount + 1);
gHusbandData.PutDataInto(C.husband);
gWifeData.PutDataInto(C.wife);
C.fDate := iDate.GetValue;
end;
procedure TFamilyDoc.AddPerson (P: TPerson);
begin
fMen.Delete(P);
fWomen.Delete(P);
if P.fMale then
fMen.Insert(P)
else
fWomen.Insert(P);
end;
procedure TFamilyDoc.RemovePerson (P: TPerson);
begin
if P.fMale then
fMen.Delete(P)
else
fWomen.Delete(P);
end;
procedure TFamilyDoc.DeletePerson (P: TPerson);
var
C: TCouple;
begin
P := fCurrent;
C := P.parents;
C.Delete(P);
SetChangeCount(fChangeCount + 1);
RemovePerson(P);
SetPerson(P.Father);
P.Free;
end;
procedure TFamilyDoc.AddParents;
var
C: TCouple;
F, M: TPerson;
begin
F := NewPerson(true); {'Father',}
M := NewPerson(false); {'Mother',}
C := NewCouple(F, M);
F.fLast := fCurrent.fLast;
if EditCouple(C, 'Father', 'Mother') then
begin
F.AddSpouse(C);
fCurrent.AddParents(C);
AddPerson(F);
AddPerson(M);
fCouples.Insert(C);
end
else
begin
F.Free;
M.Free;
C.Free;
end;
end;
procedure TFamilyDoc.AddSpouse;
var
P: TPerson;
C: TCouple;
begin
P := NewPerson(not fCurrent.fMale); {'Spouse',}
if fCurrent.fMale then
C := NewCouple(fCurrent, P)
else
C := NewCouple(P, fCurrent);
if EditCouple(C, 'Husband', 'Wife') then
begin
fCurrent.AddSpouse(C);
AddPerson(P);
fCouples.Insert(C);
end
else
begin
P.Free;
C.Free;
end;
end;
procedure TFamilyDoc.AddChild;
var
P: TPerson;
begin
P := NewPerson(true); {default is male}
P.fLast := TCouple(fCurrent.Last).husband.fLast;
if EditPerson(P, 'Child') then
begin
fCurrent.AddChild(P);
AddPerson(P);
end
else
begin
P.Free;
end;
end;
procedure TFamilyDoc.SetPerson (P: TPerson);
var
S: str255;
begin
FailNil(P);
fCurrent := P;
iFather.SetPerson(P.Father);
iMother.SetPerson(P.Mother);
if P.fMale then
iName.InstallColor(gBlue, false)
else
iName.InstallColor(gRed, false);
iName.SetText(P.FullName, kRedraw);
S := concat(P.FullBirth, ' ', P.fPlace);
iBirth.Settext(S, kRedraw);
NumToString(fCurrent.NumberOfDescendants, S);
iNote.SetText(S, kRedraw);
SetFamilyView;
end;
procedure TFamilyDoc.SetFamilyView;
procedure DoToChild (child: TObject);
begin
fFamily.InsertLast(child);
end;
procedure DoToSpouse (C: TCouple);
begin
if fCurrent.fMale then
fFamily.InsertLast(C.wife)
else
fFamily.InsertLast(C.husband);
iFamily.fSpouses := iFamily.fSpouses + [fFamily.fSize];
C.Each(DoToChild);
end;
begin
iFamily.fSpouses := [];
fFamily.DeleteAll;
fCurrent.Each(DoToSpouse);
iFamily.SetNumberOfItems(fFamily.fSize + 1);
iFamily.SelectItem(0, false, false, true);
end;
procedure TFamilyDoc.DoMakeViews (forPrinting: BOOLEAN);
OVERRIDE;
var
W: TWindow;
begin
{$IFC qDebug}
{gIntenseDebugging := true;}
{gTracing := true;}
{$ENDC}
W := NewTemplateWindow(kWindowID, SELF);
{$IFC qDebug}
{gTracing := false;}
{gIntenseDebugging := false;}
{$ENDC}
FailNIL(W);
iFather := TActiveText(W.FindSubView('fadr'));
iFather.fDocument := SELF;
iFather.SetPerson(nil);
iMother := TActiveText(W.FindSubView('modr'));
iMother.fDocument := SELF;
iMother.SetPerson(nil);
iName := TStaticText(W.FindSubView('name'));
iBirth := TStaticText(W.FindSubView('birt'));
iNote := TEditText(W.FindSubView('note'));
iFamily := TFamilyView(W.FindSubView('faml'));
if fMen.fSize = 0 then {We cannot do this at DoRead or ‹nitialState--View needed!}
SetPerson(TPerson(fWomen.At(1)))
else
SetPerson(TPerson(fMen.At(1)));
end;
procedure TFamilyDoc.DoChoice (origView: TView; itsChoice: INTEGER);
OVERRIDE;
begin
{$IFC false}
WRITELN('DoChoice ', origView.fIdentifier, itsChoice);
{$ENDC}
if (origView.fIdentifier = 'name') & EditPerson(fCurrent, fCurrent.fFirst) then
SetPerson(fCurrent);
end;
procedure TFamilyDoc.DoSetupMenus;
OVERRIDE;
var
KnownParents: boolean;
begin
inherited DoSetupMenus;
KnownParents := (fCurrent.parents <> nil);
Enable(cAncestor, fCurrent.parents <> nil);
Enable(cDescendant, fCurrent.fSize > 0);
Enable(cAddParents, not KnownParents);
Enable(cAddSpouse, true);
Enable(cAddChild, true);
Enable(cEditPerson, true);
Enable(cDelePerson, KnownParents & (fCurrent.fSize = 0));
Enable(cDispFather, KnownParents);
Enable(cDispMother, KnownParents);
Enable(cDispSpouse, fFamily.fSize > 0);
Enable(cDispChild, fFamily.fSize > 1);
{Enable(cSave, TRUE);}
end;
function TFamilyDoc.DoMenuCommand (aCmdNumber: CmdNumber): TCommand;
OVERRIDE;
begin
DoMenuCommand := nil;
case aCmdNumber of
cAncestor:
fCurrent.MakeAncestors(4);
cDescendant:
fCurrent.MakeDescendants(4);
cAddParents:
iFather.DoChoice(iFather, 0);
cAddSpouse:
begin {option-click on last item of iFamily}
AddSpouse;
SetPerson(fCurrent);
end;
cAddChild:
iFamily.SelectItem(fFamily.fSize + 1, false, false, true);
cEditPerson:
DoChoice(iName, 0);
cDelePerson:
DeletePerson(fCurrent);
cDispFather:
iFather.DoChoice(iFather, 0);
cDispMother:
iMother.DoChoice(iMother, 0);
cDispSpouse:
iFamily.SelectItem(1, false, false, true);
cDispChild:
iFamily.SelectItem(2, false, false, true);
{cGoto: ;}
otherwise
DoMenuCommand := inherited DoMenuCommand(aCmdNumber);
end;
end;
function TFamilyDoc.DoKeyCommand (ch: Char; aKeyCode: INTEGER; var info: EventInfo): TCommand;
OVERRIDE;
var
k: integer;
begin
DoKeyCommand := nil;
case ch of
chReturn:
DoChoice(iName, 0);
'F', 'f':
iFather.DoChoice(iFather, 0);
'M', 'm':
iMother.DoChoice(iMother, 0);
'1'..'9':
begin
k := ord(ch) - ord('0');
if k <= fFamily.fSize + 1 then
iFamily.SelectItem(k, false, false, true);
end;
otherwise
DoKeyCommand := inherited DoKeyCommand(ch, aKeyCode, info);
end;
end;
procedure TFamilyDoc.DoInitialState;
OVERRIDE;
var
P: TPerson;
begin
P := NewPerson(true);
if EditPerson(P, 'First Person') then
AddPerson(P)
else
begin
P.Free;
Failure(0, 0);
end;
end;
procedure TFamilyDoc.DoRead (aRefNum: INTEGER; rsrcExists, forPrinting: BOOLEAN);
OVERRIDE;
var
F: TTextFile;
pos: integer;
Line: str255;
procedure ReadNewLine;
begin
Line := F.NextLine;
pos := 0;
end;
function NextField: str255;
var
i: integer;
X: str255;
begin
i := 0;
pos := pos + 1;
while (pos <= length(Line)) & (Line[pos] <> chTAB) do
begin
i := i + 1;
X[i] := Line[pos];
pos := pos + 1;
end;
X[0] := chr(i);
NextField := X;
end;
procedure InitLists;
var
N: longint;
k: integer;
P: TPerson;
C: TCouple;
begin
ReadNewLine;
StringToNum(NextField, N);
for k := 1 to N do
begin
New(P);
FailNil(P);
P.Init;
P.fMale := true;
fMen.InsertLast(P);
end;
StringToNum(NextField, N);
for k := 1 to N do
begin
New(P);
FailNil(P);
P.Init;
P.fMale := false;
fWomen.InsertLast(P);
end;
StringToNum(NextField, N);
for k := 1 to N do
begin
New(C);
FailNil(C);
C.Init;
fCouples.InsertLast(C);
end;
end;
procedure ReadPerson (P: TPerson);
var
N: longint;
T: str255;
begin
ReadNewLine;
T := NextField; {Skip record number}
P.fFirst := NextField;
P.fLast := NextField;
P.fPlace := NextField;
StringToNum(NextField, N);
P.fBirth := N;
StringToNum(NextField, N);
P.fDeath := N;
StringToNum(NextField, N);
{$IFC qDebug}
WRITELN(T, ' ', P.fFirst, N);
{$ENDC}
if N <> 0 then
P.AddParents(TCouple(fCouples.At(N)));
end;
procedure ReadCouple (C: TCouple);
var
N: longint;
T: str255;
begin
ReadNewLine;
T := NextField; {Skip record number}
StringToNum(NextField, N);
C.fDate := N;
StringToNum(NextField, N);
C.husband := TPerson(fMen.At(N));
StringToNum(NextField, N);
C.wife := TPerson(fWomen.At(N));
{$IFC qDebug}
WRITELN(T, ' ', C.husband.fFirst, '-', C.wife.fFirst);
{$ENDC}
C.husband.AddSpouse(C);
end;
begin
new(F);
FailNil(F);
F.ITextFile(aRefNum, kTempMem);
InitLists;
{$IFC qDebug}
WRITELN(fMen.fSize, fWomen.fSize, fCouples.fSize);
{$ENDC}
fMen.Each(ReadPerson);
fWomen.Each(ReadPerson);
fCouples.Each(ReadCouple);
fMen.Sort;
fWomen.Sort;
F.Free;
end;
procedure TFamilyDoc.DoWrite (aRefNum: INTEGER; makingCopy: BOOLEAN);
OVERRIDE;
var
F: TTextFile;
k: integer;
S: str255;
procedure ConcatLongint (N: longint);
var
T: str255;
begin
NumToString(N, T);
S := concat(S, chTAB, T);
end;
procedure ConcatObjectID (P: TObject; L: TList);
begin
if (P = nil) | (L = nil) | (L.fSize = 0) then
ConcatLongint(0)
else
ConcatLongint(L.GetSameItemNo(P));
end;
procedure WritePerson (P: TPerson);
begin
k := k + 1;
NumToString(k, S);
S := concat(S, chTAB, P.fFirst, chTAB, P.fLast, chTAB, P.fPlace);
ConcatLongint(P.fBirth);
ConcatLongint(P.fDeath);
ConcatObjectID(P.parents, fCouples);
F.WriteLine(S);
end;
procedure WriteCouple (C: TCouple);
begin
k := k + 1;
NumToString(k, S);
ConcatLongint(C.fDate);
ConcatObjectID(C.husband, fMen);
ConcatObjectID(C.wife, fWomen);
F.WriteLine(S);
end;
begin
new(F);
FailNil(F);
F.ITextFile(aRefNum, kDisk);
NumToString(fMen.fSize, S);
ConcatLongint(fWomen.fSize);
ConcatLongint(fCouples.fSize);
F.WriteLine(S);
k := 0;
fMen.Each(WritePerson);
k := 0;
fWomen.Each(WritePerson);
k := 0;
fCouples.Each(WriteCouple);
F.Free;
end;
procedure TFamilyDoc.DoNeedDiskSpace (var dataForkBytes, rsrcForkBytes: LONGINT);
OVERRIDE;
begin
dataForkBytes := dataForkBytes + 50 * (fMen.fSize + fWomen.fSize + fCouples.fSize);
end;
{==========================================================================}
{ TPersonCluster }
{==========================================================================}
procedure TPersonCluster.Init;
begin
iMale := TCheckBox(FindSubView('male'));
FailNIL(iMale);
iFrst := TEditText(FindSubView('frst'));
FailNIL(iFrst);
iLast := TEditText(FindSubView('last'));
FailNIL(iLast);
iPlac := TEditText(FindSubView('plac'));
FailNIL(iPlac);
iBirt := TNumberText(FindSubView('birt'));
FailNIL(iBirt);
iDeat := TNumberText(FindSubView('deat'));
FailNIL(iDeat);
iNote := TEditText(FindSubView('note'));
FailNIL(iNote);
end;
procedure TPersonCluster.GetDataFrom (P: TPerson);
begin
iMale.SetState(P.fMale, not kRedraw);
iFrst.SetText(P.fFirst, false);
iLast.SetText(P.fLast, false);
iPlac.SetText(P.fPlace, false);
iBirt.SetValue(P.fBirth, false);
iDeat.SetValue(P.fDeath, false);
if (P.fLast = '') & (P.Father <> nil) then
iLast.SetText(P.Father.fLast, false);
end;
procedure TPersonCluster.PutDataInto (P: TPerson);
var
S: str255;
begin
P.fMale := iMale.isOn;
iFrst.GetText(S);
P.fFirst := S;
iLast.GetText(S);
P.fLast := S;
iPlac.GetText(S);
P.fPlace := S;
P.fBirth := iBirt.GetValue;
P.fDeath := iDeat.GetValue;
end;
{==========================================================================}
{ TFamilyView }
{==========================================================================}
procedure TFamilyView.GetItemText (anItem: INTEGER; var aString: Str255);
OVERRIDE;
var
D: TFamilyDoc;
P: TPerson;
begin
if anItem = fNumOfRows then
aString := kDontExist
else
begin
D := TFamilyDoc(fdocument);
P := TPerson(D.fFamily.At(anItem));
if (anItem in fSpouses) then
aString := concat(P.fFirst, ' ', P.fLast)
{ else if P.fBirth = 0 then }
{ aString := P.fFirst }
else
aString := concat(P.fFirst, ' ', P.FullBirth);
end;
end;
procedure TFamilyView.SelectItem (anItem: INTEGER; extendSelection, highlight, select: BOOLEAN);
OVERRIDE;
var
D: TFamilyDoc;
P: TPerson;
C: TCouple;
begin
inherited SelectItem(anItem, extendSelection, highlight, select);
if anItem = 0 then
Exit(SelectItem);
D := TFamilyDoc(fdocument);
if anItem < fNumOfRows then
begin { click on a person P }
P := TPerson(D.fFamily.At(anItem));
if not (anItem in fSpouses) & ModifierKeyIsDown then
begin
C := P.parents;
if D.EditCouple(C, 'Husband', 'Wife') then
;
P := D.fCurrent;
end;
end
else if (anItem = 1) | ModifierKeyIsDown then
begin { click on ** -- empty list or option key }
P := D.fCurrent;
D.AddSpouse;
end
else
begin { plain click on ** -- non-empty list }
P := D.fCurrent;
D.AddChild;
end;
{$IFC false}
WRITELN('Select item ', anItem : 1, ' ', P.fFirst);
{$ENDC}
if P <> nil then
D.SetPerson(P);
end;
procedure TFamilyView.SetNumberOfItems (aNumber: INTEGER);
begin
ForceRedraw;
if fNumOfRows > aNumber then
DelItemFirst(fNumOfRows - aNumber)
else if fNumOfRows < aNumber then
InsItemFirst(aNumber - fNumOfRows);
end;
function TFamilyView.DoSetCursor (localPoint: Point; cursorRgn: RgnHandle): BOOLEAN;
OVERRIDE;
var
h: CursHandle;
R: Rect;
begin
h := GetCursor(kHandCursor);
if h <> nil then
SetCursor(h^^);
GetQDExtent(R);
RectRgn(cursorRgn, R);
DoSetCursor := TRUE;
end;
procedure TFamilyView.DrawCell (aCell: GridCell; aQDRect: Rect);
OVERRIDE;
var
k: integer;
S: Str255;
D: TFamilyDoc;
begin
GetText(aCell, S);
k := aCell.v;
if (k in fSpouses) then
TextFace([bold])
else
TextFace([]);
D := TFamilyDoc(fdocument);
if k = fNumOfRows then
SetIfColor(gRGBBlack)
else if TPerson(D.fFamily.At(k)).fMale then
SetIfColor(gBlue)
else
SetIfColor(gRed);
if (GetColWidth(aCell.h) > 0) then
MADrawString(@S, aQDRect, teJustCenter);
end;
{==========================================================================}
{ TActiveText }
{==========================================================================}
function TActiveText.DoSetCursor (localPoint: Point; cursorRgn: RgnHandle): BOOLEAN;
OVERRIDE;
var
h: CursHandle;
R: Rect;
begin
h := GetCursor(kHandCursor);
if h <> nil then
SetCursor(h^^);
GetQDExtent(R);
RectRgn(cursorRgn, R);
DoSetCursor := TRUE;
end;
procedure TActiveText.DoChoice (origView: TView; itsChoice: INTEGER);
OVERRIDE;
var
D: TFamilyDoc;
P: TPerson;
C: TCouple;
begin
D := TFamilyDoc(fdocument);
if fPerson = nil then
begin
P := D.fCurrent;
D.AddParents;
end
else if ModifierKeyIsDown then
begin
P := D.fCurrent;
C := D.fCurrent.parents;
if D.EditCouple(C, 'Father', 'Mother') then
;
end
else
P := fPerson;
{$IFC false}
WRITELN('DoChoice ', fIdentifier);
{$ENDC}
if P <> nil then
D.SetPerson(P);
end;
procedure TActiveText.SetPerson (P: TPerson);
begin
fPerson := P;
if P = nil then
SetText(kDontExist, kRedraw)
else
SetText(P.fFirst, kRedraw);
end;
{==========================================================================}
{ Fields }
{==========================================================================}
procedure TPerson.GetInspectorName (var inspectorName: Str255);
OVERRIDE;
begin
inspectorName := fFirst;
end;
procedure TPerson.DynamicFields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
OVERRIDE;
begin
end;
procedure TPerson.Fields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
OVERRIDE;
var
k: integer;
S: str255;
X: TObject;
begin
if fMale then
DoToField('TPerson (male)', nil, bClass)
else
DoToField('TPerson (female)', nil, bClass);
DoToField('first', @fFirst, bString);
DoToField('last', @fLast, bString);
DoToField('birth', @fBirth, bLongint);
DoToField('death', @fDeath, bLongint);
DoToField('place', @fPlace, bString);
DoToField('parents', @parents, bObject);
if parents <> nil then
begin
DoToField(' father', @parents.husband, bObject);
DoToField(' mother', @parents.wife, bObject);
end;
if fSize > 0 then
DoToField('spouses', nil, bTitle);
for k := 1 to fSize do
begin
X := At(k);
NumToString(k, S);
DoToField(S, @X, bObject);
end;
inherited Fields(DoToField);
end;
procedure TCouple.GetInspectorName (var inspectorName: Str255);
OVERRIDE;
begin
inspectorName := concat(husband.fFirst, '-', wife.fFirst);
end;
procedure TCouple.DynamicFields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
OVERRIDE;
begin
end;
procedure TCouple.Fields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
OVERRIDE;
var
k: ArrayIndex;
S: Str255;
X: TObject;
begin
DoToField('TCouple', nil, bClass);
DoToField('husband', @husband, bObject);
DoToField('wife', @wife, bObject);
DoToField('date', @fDate, bLongint);
DoToField('children', nil, bTitle);
for k := 1 to fSize do
begin
X := At(k);
NumToString(k, S);
DoToField(S, @X, bObject);
end;
inherited Fields(DoToField);
end;
procedure TFamilyDoc.Fields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
OVERRIDE;
begin
DoToField('TFamilyDoc', nil, bClass);
DoToField('fMen', @fMen, bObject);
DoToField('fWomen', @fWomen, bObject);
DoToField('fCouples', @fCouples, bObject);
DoToField('fCurrent', @fCurrent, bObject);
DoToField('fFamily', @fFamily, bObject);
DoToField('fSpouses', @iFamily.fSpouses, bLongint);
inherited Fields(DoToField);
end;
end.